From ba3f4e620c259c33d0d5da17e89eea922be0e4cd Mon Sep 17 00:00:00 2001
From: Přemysl Janouch <p.janouch@gmail.com>
Date: Thu, 31 Jul 2014 02:31:34 +0200
Subject: script: add uncons/first/rest/>/>=/<=/!=/join

---
 plugins/script | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 64 insertions(+), 7 deletions(-)

diff --git a/plugins/script b/plugins/script
index 9c62399..78e0217 100755
--- a/plugins/script
+++ b/plugins/script
@@ -1009,6 +1009,28 @@ defn (fn_cat)
 	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 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
 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
-//
-//   join { list delim -- string } -- string join -> script this
-//
+//   length -- length of a list/string
 //   -, /, %, ** -- 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
-//   <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
 init_runtime_library (void)
 {
+	init_runtime_library_scripts ();
+
 	// Type detection
 	register_handler ("string?",  fn_is_string);
 	register_handler ("word?",    fn_is_word);
@@ -1680,6 +1736,7 @@ init_runtime_library (void)
 	register_handler ("unit",     fn_unit);
 	register_handler ("cons",     fn_cons);
 	register_handler ("cat",      fn_cat);
+	register_handler ("uncons",   fn_uncons);
 
 	// Arithmetic operations
 	register_handler ("*",        fn_times);
-- 
cgit v1.2.3-70-g09d2