hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added experimental code to execute an external command

Browse Source
This commit is contained in:
hyung-hwan 2018-08-02 17:09:32 +00:00
parent f90adb468e
commit 25243fc7af
4 changed files with 191 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
lib/comp.c
View File

@ -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,6 +1483,8 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
}
}
if (HCL_IS_SYMBOL(hcl, car))
{
sdc = hcl_getatsysdic(hcl, car);
if (sdc)
{
@ -1497,7 +1499,8 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
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);
}
}

17
lib/dic.c
View File

@ -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;

157
lib/exec.c
View File

@ -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;
}

7
lib/hcl.h
View File

@ -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 */