script: add uncons/first/rest/>/>=/<=/!=/join
This commit is contained in:
parent
f62dbe9546
commit
ba3f4e620c
|
@ -1009,6 +1009,28 @@ defn (fn_cat)
|
||||||
return true;
|
return true;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
defn (fn_uncons)
|
||||||
|
{
|
||||||
|
check_stack (1);
|
||||||
|
struct item *list = pop (ctx);
|
||||||
|
if (!check_type (ctx, list, ITEM_LIST))
|
||||||
|
goto fail;
|
||||||
|
struct item *first = get_list (list);
|
||||||
|
if (!first)
|
||||||
|
{
|
||||||
|
ctx->error = strdup ("list is empty");
|
||||||
|
goto fail;
|
||||||
|
}
|
||||||
|
((struct item_list *) list)->head = first->next;
|
||||||
|
first->next = NULL;
|
||||||
|
push (ctx, first);
|
||||||
|
push (ctx, list);
|
||||||
|
return true;
|
||||||
|
fail:
|
||||||
|
item_free (list);
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
|
||||||
// - - Logical - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
// - - Logical - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||||
|
|
||||||
static bool
|
static bool
|
||||||
|
@ -1632,19 +1654,53 @@ item_list_to_str (const struct item *script, struct buffer *buf)
|
||||||
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
// - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||||
|
|
||||||
// TODO: implement more functions; try to avoid writing it in C
|
// TODO: implement more functions; try to avoid writing it in C
|
||||||
//
|
// length -- length of a list/string
|
||||||
// join { list delim -- string } -- string join -> script this
|
|
||||||
//
|
|
||||||
// -, /, %, ** -- arithmetic
|
// -, /, %, ** -- arithmetic
|
||||||
// >, !=, <=, >= -- comparison
|
|
||||||
// first -- first character of a string, first element in a list
|
|
||||||
// rest -- [1:] of a string, the "tail" in a list
|
|
||||||
// at { value index -- sub-value } -- get n-th subvalue of a string/list
|
// at { value index -- sub-value } -- get n-th subvalue of a string/list
|
||||||
// <each> step { value program } -- foreach
|
|
||||||
|
static void
|
||||||
|
init_runtime_library_scripts (void)
|
||||||
|
{
|
||||||
|
struct script
|
||||||
|
{
|
||||||
|
const char *name;
|
||||||
|
const char *definition;
|
||||||
|
}
|
||||||
|
scripts[] =
|
||||||
|
{
|
||||||
|
{ "swons", "swap cons" },
|
||||||
|
{ "first", "uncons drop" },
|
||||||
|
{ "rest", "uncons swap drop" },
|
||||||
|
|
||||||
|
{ ">", "swap <" },
|
||||||
|
{ "!=", "= not" },
|
||||||
|
{ "<=", "> not" },
|
||||||
|
{ ">=", "< not" },
|
||||||
|
|
||||||
|
// XXX: this is a bit crazy and does not work with an empty list
|
||||||
|
{ "join", "[uncons] dip swap [[dup] dip swap [+ +] dip] each drop" },
|
||||||
|
};
|
||||||
|
|
||||||
|
for (size_t i = 0; i < N_ELEMENTS (scripts); i++)
|
||||||
|
{
|
||||||
|
char *error = NULL;
|
||||||
|
struct item *script = parse (scripts[i].definition, &error);
|
||||||
|
if (error)
|
||||||
|
{
|
||||||
|
fprintf (stderr, "error parsing internal script `%s': %s=n",
|
||||||
|
scripts[i].definition, error);
|
||||||
|
free (error);
|
||||||
|
exit (EXIT_FAILURE);
|
||||||
|
}
|
||||||
|
register_script (scripts[i].name, script);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
static void
|
static void
|
||||||
init_runtime_library (void)
|
init_runtime_library (void)
|
||||||
{
|
{
|
||||||
|
init_runtime_library_scripts ();
|
||||||
|
|
||||||
// Type detection
|
// Type detection
|
||||||
register_handler ("string?", fn_is_string);
|
register_handler ("string?", fn_is_string);
|
||||||
register_handler ("word?", fn_is_word);
|
register_handler ("word?", fn_is_word);
|
||||||
|
@ -1680,6 +1736,7 @@ init_runtime_library (void)
|
||||||
register_handler ("unit", fn_unit);
|
register_handler ("unit", fn_unit);
|
||||||
register_handler ("cons", fn_cons);
|
register_handler ("cons", fn_cons);
|
||||||
register_handler ("cat", fn_cat);
|
register_handler ("cat", fn_cat);
|
||||||
|
register_handler ("uncons", fn_uncons);
|
||||||
|
|
||||||
// Arithmetic operations
|
// Arithmetic operations
|
||||||
register_handler ("*", fn_times);
|
register_handler ("*", fn_times);
|
||||||
|
|
Loading…
Reference in New Issue