added qse_getprimno() and added experimental code for foreign function interface

stix/lib/Stix.st

@@ -14,40 +14,45 @@
 
 	#method(#class) dump
 	{
-		<primitive: 0>
+		<primitive: #dump>
 	}
 
 	#method dump
 	{
-		<primitive: 0>
+		<primitive: #dump>
 	}
 
 	#method(#class) new
 	{
-		<primitive: 1>
+		## <primitive: 1>
+		<primitive: #new>
 	}
 
 	#method(#class) new: anInteger
 	{
-		<primitive: 2>
+		## <primitive: 2>
+		<primitive: #new:>
 	}
 
 	#method basicSize
 	{
-		<primitive: 3>
+		## <primitive: 3>
+		<primitive: #basicSize>
 		^0
 	}
 
 
 	#method basicAt: anInteger
 	{
-		<primitive: 4>
+		## <primitive: 4>
+		<primitive: #basicAt:>
 		## self error: 'out of range'.
 	}
 
 	#method basicAt: anInteger put: anObject
 	{
-		<primitive: 5>
+		## <primitive: 5>
+		<primitive: #basicAt:put:>
 		## self error: 'out of range'.
 	}
 
@@ -393,3 +398,63 @@
 	#dcl owner preamble ntmprs nargs code source.
 }
 
+
+#class FFI(Object)
+{
+	#dcl name handle funcs.
+
+	#method(#class) new: aString
+	{
+		^self new open: aString.
+	}
+
+	#method open: aString
+	{
+		self.funcs := Dictionary new.
+		self.name := aString.
+		self.handle := self privateOpen: self.name.
+	}
+
+	#method close
+	{
+		self privateClose: self.handle.
+		self.handle := nil.
+	}
+
+	#method call: aFunctionName withArgs: anArgArray
+	{
+		| f |
+
+		f := self.funcs at: aFunctionName.
+		f isNil ifTrue: [
+			f := self privateGetSymbol: aFunctionName in: self.handle.
+			f isNil ifTrue: [ self error: 'No such function' ].
+			self.funcs at: aFunctionName put: f.
+		].
+
+		^self privateCall: f withArgs: anArgArray.
+	}
+
+	#method privateOpen: aString
+	{
+		<primitive: #ffiOpen>
+		## throw an exception here.
+	}
+
+	#method privateClose: aHandle
+	{
+		<primitive: #ffiClose>
+	}
+
+	#method privateCall: aFFISym withArgs: anArgArray
+	{
+		<primitive: #ffiCall>
+	}
+
+	#method privateGetSymbol: aString in: aHandle
+	{
+		<primitive: #ffiGetSym>
+	}
+}
+
+

stix/lib/comp.c

@@ -165,6 +165,7 @@ static STIX_INLINE int is_spacechar (stix_uci_t c)
 	}
 }
 
+
 static STIX_INLINE int is_alphachar (stix_uci_t c)
 {
 /* TODO: support full unicode */
@@ -217,6 +218,16 @@ static STIX_INLINE int is_binselchar (stix_uci_t c)
 	}
 }
 
+static STIX_INLINE int is_leadidentchar (stix_uci_t c)
+{
+	return is_alphachar(c) || c == '_';
+}
+
+static STIX_INLINE int is_identchar (stix_uci_t c)
+{
+	return is_alnumchar(c) || c == '_';
+}
+
 static STIX_INLINE int is_closing_char (stix_uci_t c)
 {
 	switch (c)
@@ -717,7 +728,7 @@ static int get_ident (stix_t* stix, stix_uci_t char_read_ahead)
 		ADD_TOKEN_CHAR (stix, c);
 		GET_CHAR_TO (stix, c);
 	} 
-	while (is_alnumchar(c));
+	while (is_identchar(c));
 
 	if (c == ':') 
 	{
@@ -726,7 +737,7 @@ static int get_ident (stix_t* stix, stix_uci_t char_read_ahead)
 		stix->c->tok.type = STIX_IOTOK_KEYWORD;
 		GET_CHAR_TO (stix, c);
 
-		if (stix->c->in_array && is_alphachar(c)) 
+		if (stix->c->in_array && is_leadidentchar(c)) 
 		{
 			/* when reading an array literal, read as many characters as
 			 * would compose a normal keyword symbol literal */
@@ -735,7 +746,7 @@ static int get_ident (stix_t* stix, stix_uci_t char_read_ahead)
 				ADD_TOKEN_CHAR (stix, c);
 				GET_CHAR_TO (stix, c);
 			}
-			while (is_alnumchar(c));
+			while (is_identchar(c));
 
 			if (c == ':') goto read_more_kwsym;
 			else
@@ -757,7 +768,7 @@ static int get_ident (stix_t* stix, stix_uci_t char_read_ahead)
 		read_more_seg:
 			GET_CHAR_TO (stix, c);
 
-			if (is_alphachar(c))
+			if (is_leadidentchar(c))
 			{
 				stix->c->tok.type = STIX_IOTOK_IDENT_DOTTED;
 
@@ -767,7 +778,7 @@ static int get_ident (stix_t* stix, stix_uci_t char_read_ahead)
 					ADD_TOKEN_CHAR (stix, c);
 					GET_CHAR_TO (stix, c);
 				}
-				while (is_alnumchar(c));
+				while (is_identchar(c));
 
 				if (c == '.') goto read_more_seg;
 			}
@@ -1281,14 +1292,14 @@ retry:
 						} 
 						while (is_binselchar(c));
 					}
-					else if (is_alphachar(c))
+					else if (is_leadidentchar(c)) 
 					{
 						do 
 						{
 							ADD_TOKEN_CHAR (stix, c);
 							GET_CHAR_TO (stix, c);
 						} 
-						while (is_alnumchar(c));
+						while (is_identchar(c));
 
 						if (c == ':')
 						{
@@ -1297,14 +1308,14 @@ retry:
 							ADD_TOKEN_CHAR (stix, c);
 							GET_CHAR_TO (stix, c);
 
-							if (is_alphachar(c))
+							if (is_leadidentchar(c))
 							{
 								do 
 								{
 									ADD_TOKEN_CHAR (stix, c);
 									GET_CHAR_TO (stix, c);
 								} 
-								while (is_alnumchar(c));
+								while (is_identchar(c));
 
 								if (c == ':') goto read_more_word;
 								else
@@ -1328,7 +1339,7 @@ retry:
 						read_more_seg:
 							GET_CHAR_TO (stix, c);
 
-							if (is_alphachar(c))
+							if (is_leadidentchar(c))
 							{
 								ADD_TOKEN_CHAR (stix, '.');
 								do
@@ -1336,7 +1347,7 @@ retry:
 									ADD_TOKEN_CHAR (stix, c);
 									GET_CHAR_TO (stix, c);
 								}
-								while (is_alnumchar(c));
+								while (is_identchar(c));
 
 								if (c == '.') goto read_more_seg;
 							}
@@ -1411,7 +1422,7 @@ retry:
 	 */
 
 		default:
-			if (is_alphachar(c)) 
+			if (is_leadidentchar(c)) 
 			{
 				if (get_ident(stix, STIX_UCI_EOF) <= -1) return -1;
 			}
@@ -2555,13 +2566,10 @@ static int compile_method_primitive (stix_t* stix)
  * <some-other-modifier: xxxx>
  */
 
-	GET_TOKEN (stix); /* TODO: only integer */
+	GET_TOKEN (stix); 
-	if (stix->c->tok.type != STIX_IOTOK_NUMLIT) 
+	switch (stix->c->tok.type)
 	{
-		set_syntax_error (stix, STIX_SYNERR_INTEGER, &stix->c->tok.loc, &stix->c->tok.name);
+		case STIX_IOTOK_NUMLIT: /* TODO: allow only an integer */
-		return -1;
-	}
-
 /*TODO: more checks the validity of the primitive number. support number with radix and so on support more extensive syntax. support primitive name, not number*/
 			ptr = stix->c->tok.name.ptr;
 			end = ptr + stix->c->tok.name.len;
@@ -2579,6 +2587,28 @@ static int compile_method_primitive (stix_t* stix)
 			}
 
 			stix->c->mth.prim_no = prim_no;
+			break;
+ 
+		case STIX_IOTOK_SYMLIT:
+			prim_no = stix_getprimno (stix, &stix->c->tok.name);
+			if (prim_no <= -1)
+			{
+				set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
+				return -1;
+			}
+			else if (!STIX_OOI_IN_PREAMBLE_INDEX_RANGE(prim_no))
+			{
+				set_syntax_error (stix, STIX_SYNERR_PRIMNO, &stix->c->tok.loc, &stix->c->tok.name);
+				return -1;
+			}
+			stix->c->mth.prim_no = prim_no;
+			break;
+
+		default:
+			set_syntax_error (stix, STIX_SYNERR_INTEGER, &stix->c->tok.loc, &stix->c->tok.name);
+			return -1;
+	}
+
 
 	GET_TOKEN (stix);
 	if (!is_token_binary_selector(stix, VOCA_GT)) 
@@ -2610,7 +2640,6 @@ static int get_variable_info (stix_t* stix, const stix_ucs_t* name, const stix_i
 		stix_oop_association_t ass;
 		const stix_uch_t* dot;
 
-
 		dot = stix_findchar (name->ptr, name->len, '.');
 		STIX_ASSERT (dot != STIX_NULL);
 		if (dot - name->ptr == 4 && stix_equalchars(name->ptr, vocas[VOCA_SELF].str, 4))
@@ -3298,7 +3327,6 @@ static int compile_expression_primary (stix_t* stix, const stix_ucs_t* ident, co
 	if (ident) 
 	{
 		/* the caller has read the identifier and the next word */
-
 	handle_ident:
 		if (get_variable_info(stix, ident, ident_loc, ident_dotted, &var) <= -1) return -1;
 
@@ -3370,6 +3398,7 @@ printf ("\tpush object %d\n", (int)index);
 		switch (stix->c->tok.type)
 		{
 			case STIX_IOTOK_IDENT_DOTTED:
+				ident_dotted = 1;
 			case STIX_IOTOK_IDENT:
 				ident = &stix->c->tok.name;
 				ident_loc = &stix->c->tok.loc;

stix/lib/exec.c

@@ -26,6 +26,8 @@
 
 #include "stix-prv.h"
 
+#include <dlfcn.h> /* TODO: remove this. make dlXXX calls to callbacks */
+
 /* TODO: context's stack overflow check in various part of this file */
 /* TOOD: determine the right stack size */
 #define CONTEXT_STACK_SIZE 96
@@ -355,6 +357,8 @@ TODO: overcome this problem
 	return activate_new_method (stix, mth);
 }
 
+
+/* ------------------------------------------------------------------------- */
 static int primitive_dump (stix_t* stix, stix_ooi_t nargs)
 {
 	stix_ooi_t i;
@@ -447,7 +451,6 @@ static int primitive_basic_size (stix_t* stix, stix_ooi_t nargs)
 	stix_oop_t rcv;
 	STIX_ASSERT (nargs == 0);
 
-
 	rcv = ACTIVE_STACK_GETTOP(stix);
 	ACTIVE_STACK_SETTOP(stix, STIX_OOP_FROM_SMINT(STIX_OBJ_GET_SIZE(rcv)));
 /* TODO: use LargeInteger if the size is very big */
@@ -846,6 +849,155 @@ static int primitive_integer_gt (stix_t* stix, stix_ooi_t nargs)
 	return 0;
 }
 
+static int primitive_ffi_open (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t rcv, arg;
+	void* handle;
+
+	STIX_ASSERT (nargs == 1);
+
+	rcv = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	arg = ACTIVE_STACK_GET(stix, stix->sp);
+
+	if (STIX_OBJ_GET_FLAGS_TYPE(arg) != STIX_OBJ_TYPE_CHAR)
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+
+{ ///////////////////////
+/* TODO: grow buffer */
+	stix_bch_t bcs[128];
+	stix_size_t ucslen, bcslen;
+
+	bcslen = STIX_COUNTOF(bcs);
+	ucslen = STIX_OBJ_GET_SIZE(arg);
+	if (stix_ucstoutf8 (((stix_oop_char_t)arg)->slot, &ucslen, bcs, &bcslen) <= -1)
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	bcs[bcslen] = '\0';
+	handle = dlopen (bcs, RTLD_NOW);
+	if (!handle) 
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+} ///////////////////////
+
+	ACTIVE_STACK_POP (stix);
+/* TODO: how to hold an address? as an integer????  or a byte array? */
+	ACTIVE_STACK_SETTOP (stix, STIX_OOP_FROM_SMINT(handle));
+
+	return 1;
+}
+
+static int primitive_ffi_close (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t rcv, arg;
+	void* handle;
+
+	STIX_ASSERT (nargs == 1);
+
+	STIX_ASSERT (nargs == 1);
+
+	rcv = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	arg = ACTIVE_STACK_GET(stix, stix->sp);
+
+	if (!STIX_OOP_IS_SMINT(arg))
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	ACTIVE_STACK_POP (stix);
+
+	handle = STIX_OOP_TO_SMINT(arg); /* TODO: how to store void* ??? */
+	dlclose (handle);
+	return 1;
+}
+
+static int primitive_ffi_call (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t rcv, fun, arr;
+
+	STIX_ASSERT (nargs == 2);
+
+	rcv = ACTIVE_STACK_GET(stix, stix->sp - 2);
+	fun = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	arr = ACTIVE_STACK_GET(stix, stix->sp);
+
+	if (!STIX_OOP_IS_SMINT(fun)) /* TODO: how to store pointer  */
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	if (STIX_CLASSOF(arr) != stix->_array) /* TODO: check if arr is a kind of array??? */
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	return 1;
+}
+
+static int primitive_ffi_getsym (stix_t* stix, stix_ooi_t nargs)
+{
+	stix_oop_t rcv, hnd, nam;
+	void* handle, * sym;
+
+
+	STIX_ASSERT (nargs == 2);
+
+	rcv = ACTIVE_STACK_GET(stix, stix->sp - 2);
+	nam = ACTIVE_STACK_GET(stix, stix->sp - 1);
+	hnd = ACTIVE_STACK_GET(stix, stix->sp);
+
+	if (!STIX_OOP_IS_SMINT(hnd)) /* TODO: how to store pointer  */
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	if (STIX_OBJ_GET_FLAGS_TYPE(nam) != STIX_OBJ_TYPE_CHAR)
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+
+{ ///////////////////////
+/* TODO: grow buffer */
+	stix_bch_t bcs[128];
+	stix_size_t ucslen, bcslen;
+
+	bcslen = STIX_COUNTOF(bcs);
+	ucslen = STIX_OBJ_GET_SIZE(nam);
+	if (stix_ucstoutf8 (((stix_oop_char_t)nam)->slot, &ucslen, bcs, &bcslen) <= -1)
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+
+	bcs[bcslen] = '\0';
+	sym = dlsym (handle, bcs);
+	if (!sym) 
+	{
+		/* TODO: more info on error */
+		return 0;
+	}
+} ///////////////////////
+
+	ACTIVE_STACK_POPS (stix, 2);
+/* TODO: how to hold an address? as an integer????  or a byte array? */
+	ACTIVE_STACK_SETTOP (stix, STIX_OOP_FROM_SMINT(sym));
+
+	return 1;
+}
 
 typedef int (*primitive_handler_t) (stix_t* stix, stix_ooi_t nargs);
 
@@ -853,27 +1005,50 @@ struct primitive_t
 {
 	stix_ooi_t          nargs; /* expected number of arguments */
 	primitive_handler_t handler;
-	/* stix_ucs_t          name; */
+	const char*         name; /* the name is supposed to be 7-bit ascii only */
 };
 typedef struct primitive_t primitive_t;
 
 static primitive_t primitives[] =
 {
-	/*  0 */ {  -1,   primitive_dump                       },
+	{  -1,   primitive_dump,                 "dump"          }, /*  0 */
-	/*  1 */ {   0,   primitive_new                        },
+	{   0,   primitive_new,                  "new"           }, /*  1 */
-	/*  2 */ {   1,   primitive_new_with_size              },
+	{   1,   primitive_new_with_size,        "new:"          }, /*  2 */
-	/*  3 */ {   0,   primitive_basic_size                 },
+	{   0,   primitive_basic_size,           "basicSize"     }, /*  3 */
-	/*  4 */ {   1,   primitive_basic_at                   },
+	{   1,   primitive_basic_at,             "basicAt:"      }, /*  4 */
-	/*  5 */ {   2,   primitive_basic_at_put               },
+	{   2,   primitive_basic_at_put,         "basicAt:put:"  }, /*  5 */
-	/*  6 */ {  -1,   primitive_block_value                },
+	{  -1,   primitive_block_value,          "blockValue"    }, /*  6 */
-	/*  7 */ {   1,   primitive_integer_add                },
+	{   1,   primitive_integer_add,          "integerAdd:"   }, /*  7 */
-	/*  8 */ {   1,   primitive_integer_sub                },
+	{   1,   primitive_integer_sub,          "integerSub:"   }, /*  8 */
-	/*  9 */ {   1,   primitive_integer_mul                },
+	{   1,   primitive_integer_mul,          "integerMul:"   }, /*  9 */
-	/* 10 */ {   1,   primitive_integer_eq                 },
+	{   1,   primitive_integer_eq,           "integerEq:"    }, /* 10 */
-	/* 11 */ {   1,   primitive_integer_lt                 },
+	{   1,   primitive_integer_lt,           "integerLt:"    }, /* 11 */
-	/* 12 */ {   1,   primitive_integer_gt                 }
+	{   1,   primitive_integer_gt,           "integerGt:"    }, /* 12 */
+
+	{   1,   primitive_ffi_open,             "ffiOpen"       },
+	{   1,   primitive_ffi_close,            "ffiClose"      },
+	{   2,   primitive_ffi_call,             "ffiCall"       },
+	{   2,   primitive_ffi_getsym,           "ffiGetSym"     }
 };
 
+int stix_getprimno (stix_t* stix, const stix_ucs_t* name)
+{
+	int i;
+
+	for (i = 0; i < STIX_COUNTOF(primitives); i++)
+	{
+		if (stix_equalchars2(name, primitives[i].name))
+		{
+			return i;
+		}
+	}
+
+	stix->errnum = STIX_ENOENT;
+	return -1;
+}
+
+/* ------------------------------------------------------------------------- */
+
 int stix_execute (stix_t* stix)
 {
 	stix_byte_t bcode;

stix/lib/stix-prv.h

@@ -856,6 +856,11 @@ int stix_equalchars (
 	stix_size_t         len
 );
 
+int stix_equalchars2 (
+	const stix_ucs_t* str1,
+	const char*       str2
+);
+
 void stix_copychars (
 	stix_uch_t*       dst,
 	const stix_uch_t* src,
@@ -1065,6 +1070,13 @@ void stix_getsynerr (
 	stix_synerr_t* synerr
 );
 
+/* ========================================================================= */
+/* exec.c                                                                    */
+/* ========================================================================= */
+int stix_getprimno (
+	stix_t*           stix,
+	const stix_ucs_t* name
+);
 
 /* TODO: remove debugging functions */
 /* ========================================================================= */

stix/lib/stix.c

@@ -214,6 +214,21 @@ int stix_equalchars (const stix_uch_t* str1, const stix_uch_t* str2, stix_size_t
 	return 1;
 }
 
+int stix_equalchars2 (const stix_ucs_t* str1, const char* str2)
+{
+	const stix_uch_t* ptr, * end;
+
+	ptr = str1->ptr;
+	end = str1->ptr + str1->len;
+	while (ptr < end && *ptr == *str2 && *str2 != '\0') 
+	{
+		ptr++;
+		str2++;
+	}
+
+	return ptr >= end && *str2 == '\0';
+}
+
 void stix_copychars (stix_uch_t* dst, const stix_uch_t* src, stix_size_t len)
 {
 	stix_size_t i;

stix/lib/test-005.st

@@ -195,7 +195,7 @@
 	}
 ## ----------------------------------------------------------------------
 
-	#method(#class) main
+	#method(#class) main22
 	{
 		|a b c d e f g h i j k sum |
 
@@ -224,6 +224,13 @@
 		[self getTen] value dump.
 	}
 
+	#method(#class) main
+	{
+		| ffi |
+		ffi := FFI new: 'libc.so.6'.
+		ffi call: #printf withArgs: #((str '%d') (int 10) (long 20)).
+		ffi close.
+	}
 }