added experimental code to execute an external command

lib/comp.c

@@ -1435,7 +1435,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
 				return -1;
 		}
 	}
-	else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_XLIST(hcl,car))
+	else if (HCL_IS_SYMBOL(hcl,car) || HCL_IS_CONS_XLIST(hcl,car) || ((hcl->option.trait & HCL_CLI_MODE) && HCL_IS_STRING(hcl, car)))
 	{
 		/* normal function call 
 		 *  (<operator> <operand1> ...) */
@@ -1449,7 +1449,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
 		 *       many operations can be performed without taking GC into account */
 
 		/* store the position of COP_EMIT_CALL to be produced with
-		 * SWITCH_TOP_CFRAM() in oldtop for argument count patching 
+		 * SWITCH_TOP_CFRAME() in oldtop for argument count patching 
 		 * further down */
 		oldtop = GET_TOP_CFRAME_INDEX(hcl); 
 		HCL_ASSERT (hcl, oldtop >= 0);
@@ -1483,21 +1483,24 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
 			}
 		}
 
-		sdc = hcl_getatsysdic(hcl, car);
+		if (HCL_IS_SYMBOL(hcl, car))
-		if (sdc)
 		{
-			hcl_oop_word_t sdv;
+			sdc = hcl_getatsysdic(hcl, car);
-			sdv = (hcl_oop_word_t)HCL_CONS_CDR(sdc);
+			if (sdc)
-			if (HCL_IS_PRIM(hcl, sdv))
 			{
-				if (nargs < sdv->slot[1] || nargs > sdv->slot[2])
+				hcl_oop_word_t sdv;
+				sdv = (hcl_oop_word_t)HCL_CONS_CDR(sdc);
+				if (HCL_IS_PRIM(hcl, sdv))
 				{
-					hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, 
+					if (nargs < sdv->slot[1] || nargs > sdv->slot[2])
-						"parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); 
+					{
-					return -1;
+						hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGCOUNT, HCL_NULL, HCL_NULL, 
+							"parameters count(%zd) mismatch in function call - %O - expecting %zu-%zu parameters", nargs, obj, sdv->slot[1], sdv->slot[2]); 
+						return -1;
+					}
 				}
 			}
-		};
+		}
 
 		/* redundant cdr check is performed inside compile_object_list() */
 		PUSH_SUBCFRAME (hcl, COP_COMPILE_ARGUMENT_LIST, cdr);
@@ -1564,27 +1567,27 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj)
 	}
 
 	/* check if a symbol is a local variable */
-	if (find_temporary_variable_backward (hcl, obj, &index) <= -1)
+	if (find_temporary_variable_backward(hcl, obj, &index) <= -1)
 	{
 		hcl_oop_t cons;
 /* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */
 /* TODO: change the scheme... allow declaration??? */
 		/* global variable */
-		cons = (hcl_oop_t)hcl_getatsysdic (hcl, obj);
+		cons = (hcl_oop_t)hcl_getatsysdic(hcl, obj);
 		if (!cons) 
 		{
-			cons = (hcl_oop_t)hcl_putatsysdic (hcl, obj, hcl->_nil);
+			cons = (hcl_oop_t)hcl_putatsysdic(hcl, obj, hcl->_nil);
 			if (!cons) return -1;
 		}
 
 		if (add_literal(hcl, cons, &index) <= -1 ||
-		    emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1;
+		    emit_single_param_instruction(hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1;
 
 		return 0;
 	}
 	else
 	{
-		return emit_indexed_variable_access (hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0);
+		return emit_indexed_variable_access(hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0);
 	}
 }
 

lib/dic.c

@@ -26,7 +26,7 @@
 
 #include "hcl-prv.h"
 
-/*#define SYMBOL_ONLY_KEY */
+#define SYMBOL_ONLY_KEY 
 
 static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 {
@@ -73,6 +73,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 		if ((hcl_oop_t)ass != hcl->_nil)
 		{
 		#if defined(SYMBOL_ONLY_KEY)
+			hcl_oop_char_t key;
 			HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
 			key = (hcl_oop_char_t)ass->car;
 			HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,key));
@@ -81,7 +82,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 			int n;
 			HCL_ASSERT (hcl, HCL_IS_CONS(hcl,ass));
 			n = hcl_hashobj(hcl, ass->car, &index);
-			HCL_ASSERT (hcl, n == 0); /* since it's expanding, the existing in the bucket should always be hashable */
+			HCL_ASSERT (hcl, n == 0); /* since it's expanding, the existing one in the bucket should always be hashable */
 			index %= newsz;
 		#endif
 			while (newbuc->slot[index] != hcl->_nil) index = (index + 1) % newsz;
@@ -92,11 +93,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 	return newbuc;
 }
 
-#if defined(SYMBOL_ONLY_KEY)
-static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_char_t key, hcl_oop_t value)
-#else
 static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key, hcl_oop_t value)
-#endif
 {
 	hcl_ooi_t tally;
 	hcl_oow_t index;
@@ -112,7 +109,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
 	HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket));
 
 #if defined(SYMBOL_ONLY_KEY)
-	index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
+	index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
 #else
 	if (hcl_hashobj(hcl, key, &index) <= -1) return HCL_NULL;
 	index %= HCL_OBJ_GET_SIZE(dic->bucket);
@@ -127,7 +124,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
 		HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl,ass->car));
 
 		if (HCL_OBJ_GET_SIZE(key) == HCL_OBJ_GET_SIZE(ass->car) &&
-		    hcl_equal_oochars(key->slot, ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) 
+		    hcl_equal_oochars(HCL_OBJ_GET_CHAR_SLOT(key), ((hcl_oop_char_t)ass->car)->slot, HCL_OBJ_GET_SIZE(key))) 
 		{
 			/* the value of HCL_NULL indicates no insertion or update. */
 			if (value) ass->cdr = value; /* update */
@@ -198,7 +195,7 @@ static hcl_oop_cons_t find_or_upsert (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t k
 
 	#if defined(SYMBOL_ONLY_KEY)
 		/* recalculate the index for the expanded bucket */
-		index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
+		index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % HCL_OBJ_GET_SIZE(dic->bucket);
 	#else
 		hcl_hashobj(hcl, key, &index); /* this must succeed as i know 'key' is hashable */
 		index %= HCL_OBJ_GET_SIZE(dic->bucket);
@@ -285,7 +282,7 @@ int hcl_zapatdic (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_t key)
 	HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl,dic->bucket));
 
 #if defined(SYMBOL_ONLY_KEY)
-	index = hcl_hashoochars(key->slot, HCL_OBJ_GET_SIZE(key)) % bs;
+	index = hcl_hashoochars(HCL_OBJ_GET_CHAR_SLOT(key), HCL_OBJ_GET_SIZE(key)) % bs;
 #else
 	if (hcl_hashobj(hcl, key, &index) <= -1) return -1;
 	index %= bs;

lib/exec.c

@@ -1000,6 +1000,160 @@ static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs)
 	return ((hcl_pfimpl_t)rcv->slot[0]) (hcl, (hcl_mod_t*)rcv->slot[3], nargs);
 }
 
+
+#include <unistd.h>
+#include <sys/wait.h>
+#include <sys/stat.h>
+#include <limits.h>
+#include <string.h>
+#include <stdlib.h>
+#include <errno.h>
+
+extern char **environ;
+
+#define _PATH_DEFPATH "/usr/bin:/bin"
+
+static int is_regular_executable_file_by_me(const char *path)
+{
+	struct stat path_stat;
+	stat(path, &path_stat);
+	return S_ISREG(path_stat.st_mode) && access(path, X_OK) == 0; //? use eaccess instead??
+}
+
+static char* find_exec (hcl_t* hcl, const char *name)
+{
+	size_t lp, ln;
+	char buf[PATH_MAX];
+	const char *bp, *path, *p;
+
+	bp = buf;
+
+	/* Get the path we're searching. */
+	if (!(path = getenv("PATH"))) path = _PATH_DEFPATH;
+
+	ln = strlen(name);
+	do 
+	{
+		/* Find the end of this path element. */
+		for (p = path; *path != 0 && *path != ':'; path++) ;
+
+		/*
+		 * It's a SHELL path -- double, leading and trailing colons
+		 * mean the current directory.
+		 */
+		if (p == path) 
+		{
+			p = ".";
+			lp = 1;
+		}
+		else
+		{
+			lp = path - p;
+		}
+
+		/*
+		 * If the path is too long complain.  This is a possible
+		 * security issue; given a way to make the path too long
+		 * the user may execute the wrong program.
+		 */
+		if (lp + ln + 2 > sizeof(buf)) continue;
+
+		memcpy(buf, p, lp);
+		buf[lp] = '/';
+		memcpy(buf + lp + 1, name, ln);
+		buf[lp + ln + 1] = '\0';
+
+		if (is_regular_executable_file_by_me(bp)) return strdup(bp);
+
+	} 
+	while (*path++ == ':'); /* Otherwise, *path was NUL */
+
+
+done:
+	hcl_seterrbfmt (hcl, HCL_ENOENT, "callable %hs not found", name);
+	return HCL_NULL;
+}
+
+
+static HCL_INLINE int exec_syscmd (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	hcl_oop_word_t rcv;
+	hcl_bch_t* cmd, * xcmd;
+
+	rcv = (hcl_oop_word_t)HCL_STACK_GETRCV(hcl, nargs);
+	/*HCL_ASSERT (hcl, HCL_IS_STRING(hcl, rcv) || HCL_IS_SYMBOL(hcl, rcv));*/
+	HCL_ASSERT (hcl, HCL_OBJ_IS_CHAR_POINTER(rcv));
+
+	if (HCL_OBJ_GET_SIZE(rcv) == 0 || hcl_count_oocstr(HCL_OBJ_GET_CHAR_SLOT(rcv)) != HCL_OBJ_GET_SIZE(rcv))
+	{
+		/* '\0' is contained in the middle */
+		hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid callable %O", rcv);
+		return -1;
+	}
+
+	cmd = hcl_dupootobcstr(hcl, HCL_OBJ_GET_CHAR_SLOT(rcv), HCL_NULL);
+	if (!cmd) return -1;
+
+	if (hcl_find_bchar_in_bcstr(cmd, '/'))
+	{
+		if (!is_regular_executable_file_by_me(cmd)) 
+		{
+			hcl_seterrbfmt (hcl, HCL_ECALL, "cannot execute %O", rcv);
+			return -1;
+		}
+
+		xcmd = cmd;
+	}
+	else
+	{
+		xcmd = find_exec(hcl, cmd);
+		if (!xcmd) return -1;
+	}
+
+{ /* TODO: make it a callback ... */
+	pid_t pid;
+	int status;
+
+	pid = fork();
+	if (pid == -1) return -1;
+
+/* TODO: set a new process group / session leader??? */
+
+	if (pid == 0)
+	{
+
+			hcl_bch_t** argv;
+			hcl_ooi_t i;
+
+			/* TODO: close file descriptors??? */
+			argv = (hcl_bch_t**)hcl_allocmem(hcl, (nargs + 2) * HCL_SIZEOF(*argv));
+			if (argv)
+			{
+				argv[0] = cmd;
+				for (i = 0; i < nargs; i++)
+				{
+					hcl_oop_t ta;
+
+					ta = HCL_STACK_GETARG(hcl, nargs, i);
+/* TODO: check if an argument is a string or a symbol */
+					argv[i + 1] = hcl_dupootobchars (hcl, HCL_OBJ_GET_CHAR_SLOT(ta), HCL_OBJ_GET_SIZE(ta), HCL_NULL);
+				}
+				argv[nargs + 1] = HCL_NULL;
+				execvp (xcmd, argv);
+			}
+			_exit (255);
+	}
+
+	waitpid (pid, &status, 0);
+
+	HCL_STACK_SETRET (hcl, nargs, HCL_SMOOI_TO_OOP(WEXITSTATUS(status)));
+}
+
+	hcl_freemem (hcl, cmd);
+	if (xcmd != cmd) hcl_freemem (hcl, xcmd);
+	return 0;
+}
+
 /* ------------------------------------------------------------------------- */
 static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ctx)
 {
@@ -1584,6 +1738,9 @@ static int execute (hcl_t* hcl)
 						case HCL_BRAND_PRIM:
 							if (call_primitive(hcl, b1) <= -1) goto oops;
 							break;
+						case HCL_BRAND_STRING:
+							if ((hcl->option.trait & HCL_CLI_MODE) && exec_syscmd(hcl, b1) >= 0) break;
+							/* fall thru */
 						default:
 							goto cannot_call;
 					}

lib/hcl.h

@@ -476,6 +476,13 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
 /* [NOTE] this macro doesn't include the size of the trailer */
 #define HCL_OBJ_BYTESOF(oop) ((HCL_OBJ_GET_SIZE(oop) + HCL_OBJ_GET_FLAGS_EXTRA(oop)) * HCL_OBJ_GET_FLAGS_UNIT(oop))
 
+#define HCL_OBJ_IS_OOP_POINTER(oop)      (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP))
+#define HCL_OBJ_IS_CHAR_POINTER(oop)     (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_CHAR))
+#define HCL_OBJ_IS_BYTE_POINTER(oop)     (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_BYTE))
+#define HCL_OBJ_IS_HALFWORD_POINTER(oop) (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_HALFWORD))
+#define HCL_OBJ_IS_WORD_POINTER(oop)     (HCL_OOP_IS_POINTER(oop) && (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_WORD))
+
+
 /* [NOTE] this macro doesn't check the range of the actual value.
  *        make sure that the value of each bit fields given falls within the 
  *        possible range of the defined bits */